home *** CD-ROM | disk | FTP | other *** search
/ HAM Radio 1997 / HAM Radio 1997.iso / vcls / cltsvr / ftp.pas < prev    next >
Pascal/Delphi Source File  |  1996-04-08  |  22KB  |  851 lines
  1. unit Ftp;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls, Menus, Sockets, Login, FileGet, FilePut,
  8.   FileRen, FileView, IniFiles, Meter;
  9. type
  10.   TFTPForm = class(TForm)
  11.     Sockets1: TSockets;
  12.     Sockets2: TSockets;
  13.     MainMenu1: TMainMenu;
  14.     FileMNU: TMenuItem;
  15.     ExitMNU: TMenuItem;
  16.     DirCommandMNU: TMenuItem;
  17.     ConnectMNU: TMenuItem;
  18.     DirMNU: TMenuItem;
  19.     GetMNU: TMenuItem;
  20.     PutMNU: TMenuItem;
  21.     ChDirMNU: TMenuItem;
  22.     MkDirMNU: TMenuItem;
  23.     RmDirMNU: TMenuItem;
  24.     QuitMNU: TMenuItem;
  25.     DeleteMNU: TMenuItem;
  26.     RenameMNU: TMenuItem;
  27.     PwdMNU: TMenuItem;
  28.     N1: TMenuItem;
  29.     FileTransMNU: TMenuItem;
  30.     HelpMNU: TMenuItem;
  31.     QuoteMNU: TMenuItem;
  32.     Memo1: TMemo;
  33.     MiscCommMNU: TMenuItem;
  34.     ViewMNU: TMenuItem;
  35.     CancelMNU: TMenuItem;
  36.     ParentMNU: TMenuItem;
  37.     OptionsMNU: TMenuItem;
  38.     DirSepMNU: TMenuItem;
  39.     ViewSepMNU: TMenuItem;
  40.     EditorMNU: TMenuItem;
  41.     procedure Sockets1ErrorOccurred(Sender: TObject; Error: Integer;
  42.       Msg: String);
  43.     procedure ConnectMNUClick(Sender: TObject);
  44.     procedure DirMNUClick(Sender: TObject);
  45.     procedure QuitMNUClick(Sender: TObject);
  46.     procedure GetMNUClick(Sender: TObject);
  47.     procedure PutMNUClick(Sender: TObject);
  48.     procedure ExitMNUClick(Sender: TObject);
  49.     procedure ChDirMNUClick(Sender: TObject);
  50.     procedure MkDirMNUClick(Sender: TObject);
  51.     procedure RmDirMNUClick(Sender: TObject);
  52.     procedure PwdMNUClick(Sender: TObject);
  53.     procedure RenameMNUClick(Sender: TObject);
  54.     procedure DeleteMNUClick(Sender: TObject);
  55.     procedure HelpMNUClick(Sender: TObject);
  56.     procedure QuoteMNUClick(Sender: TObject);
  57.     procedure EnableDisableMenus;
  58.     procedure FormCreate(Sender: TObject);
  59.     procedure ViewMNUClick(Sender: TObject);
  60.     procedure CancelMNUClick(Sender: TObject);
  61.     procedure ParentMNUClick(Sender: TObject);
  62.     procedure EditorMNUClick(Sender: TObject);
  63.     procedure DirSepMNUClick(Sender: TObject);
  64.     procedure ViewSepMNUClick(Sender: TObject);
  65.   private
  66.     procedure DoPrintf(line: string; const args: array of const);
  67.     function DoDirList(cmd: string;const args: array of const): integer;
  68.     function ReadDisplayLine: integer;
  69.     function GetFTPListenPort: integer;
  70.     procedure RetrieveFile(cmd: string;LocalName: string; rtype: string);
  71.     function TimedOut: Boolean;
  72.     function getreply(cmdstring: string): integer;
  73.     function command(fmt: string; const args: array of const): integer;
  74.     procedure DoAddLine(Buff: string);
  75.     procedure ImBusy;
  76.     procedure ImFree;
  77.     procedure UpdateGauge(BytesWritten,TotalTransferSize: longint);
  78.     procedure CancelGauge;
  79.     function GetTotalRetrieveSize: longint;
  80.   public
  81.   end;
  82.  
  83. const
  84.   FTP_PRELIM = 1;
  85.   FTP_COMPLETE = 2;
  86.   FTP_CONTINUE = 3;
  87.   FTP_RETRY = 4;
  88.   FTP_ERROR = 5;
  89.  
  90. var
  91.   FTPForm: TFTPForm;
  92.   line,GlobalBuff: string;
  93.   ErrorReturn: integer;
  94.   Aborted: Boolean;
  95.   Connected: Boolean;
  96.   CmdInProgress: Boolean;
  97.   DirSep, ViewSep, Editor: string;
  98.  
  99. implementation
  100.  
  101. {$R *.DFM}
  102.  
  103. procedure TFTPForm.Sockets1ErrorOccurred(Sender: TObject; Error: Integer;
  104.   Msg: String);
  105. var
  106.   szMsg: array[0..255] of char;
  107. begin
  108.   ErrorReturn := Error;
  109.   if Error = WSAETIMEDOUT then
  110.   begin
  111.     Aborted := True;
  112.     ErrorReturn := 0;
  113.   end
  114.   else
  115.   begin
  116.     StrPCopy(szMsg,'Error: '+IntToStr(Error)+#13#10+Msg);
  117.     Application.MessageBox(szMsg,'Error',MB_ICONEXCLAMATION);
  118.   end;
  119. end;
  120.  
  121. procedure TFTPForm.RetrieveFile(cmd: string;LocalName: string; rtype: string);
  122. var
  123.   FileName: string;
  124.   szFileName: array[0..255] of char;
  125.   RecvData: string;
  126.   IsDirList: Boolean;
  127.   IsView: Boolean;
  128.   Separate: Boolean;
  129.   szBuffer: array[0..255] of char;
  130.   output_file: integer;
  131.   iret: integer;
  132.   szTempFileName: array[0..63] of char;
  133.   szCmd: array[0..63] of char;
  134.   BytesWritten: longint;
  135.   TotalRetrieveSize: longint;
  136. begin
  137.   BytesWritten := 0;
  138.   Aborted := False;
  139.   Separate := False;
  140.   output_file := 0;
  141.   { determine what the retrieve is going to do...
  142.     1) Retrieve a file
  143.     2) Directory listing
  144.        2.1) inline
  145.        2.2) seperate editor session
  146.     3) View a file
  147.        3.1) inline
  148.        3.2) seperate editor session
  149.   }
  150.   if (LocalName = '') and (copy(cmd,1,4) <> 'LIST') then
  151.   begin { goal is to view the file }
  152.     IsView := True;
  153.     if ViewSep = '1' then {separately or inline?}
  154.     begin
  155.       Separate := True;
  156.       GetTempFileName(#0,'VIW',0,szTempFileName);
  157.       output_file := _lcreat(szTempFileName,0);
  158.     end;
  159.   end
  160.   else
  161.     IsView := False;
  162.   IsDirList := False;
  163.   if copy(cmd,1,4) = 'LIST' then {goal is to perform directory listing}
  164.   begin
  165.     IsDirList := True;
  166.     if DirSep = '1' then {separately or inline?}
  167.     begin
  168.       Separate := True;
  169.       GetTempFileName(#0,'LST',0,szTempFileName);
  170.       output_file := _lcreat(szTempFileName,0);
  171.     end;
  172.   end;
  173.   if not IsDirList then
  174.   begin
  175.     if not IsView then {goal is to retrieve a file}
  176.     begin
  177.       Separate := True;
  178.       StrPCopy(szFileName,LocalName);
  179.       output_file := _lcreat(szFileName,0);
  180.       if output_file = -1 then
  181.       begin
  182.         Application.MessageBox('Could not open file','_lopen error',MB_ICONEXCLAMATION);
  183.         output_file := 0;
  184.         exit;
  185.       end;
  186.     end;
  187.   end;
  188.   if command(rtype,[nil]) = FTP_ERROR then
  189.     exit;
  190.   Sockets2.NonBlocking := False;
  191.   Sockets2.Timeout := 30;
  192.   if GetFTPListenPort = FTP_ERROR then
  193.   begin
  194.     Sockets2.SCancelListen;
  195.     exit;
  196.   end;
  197.   if IsDirList then
  198.   begin
  199.     if Separate then
  200.     begin
  201.       command('PWD',[nil]);
  202.       StrPCopy(szBuffer,GlobalBuff);
  203.       _lwrite(output_file,szBuffer,StrLen(szBuffer));
  204.       StrPCopy(szBuffer,cmd+#13#10);
  205.       _lwrite(output_file,szBuffer,StrLen(szBuffer));
  206.     end;
  207.     Sockets1.Timeout := 0; {infinite timeout}
  208.     iret := command(cmd,[nil]);
  209.     Sockets1.Timeout := 30;
  210.     if (iret = FTP_RETRY) or (iret = FTP_ERROR) then
  211.     begin
  212.       DoPrintf('Could not list directory',[nil]);
  213.       Sockets2.SCancelListen;
  214.       exit;
  215.     end;
  216.   end
  217.   else
  218.   begin
  219.     iret := command('RETR %s',[cmd]);
  220.     if (iret = FTP_RETRY) or (iret = FTP_ERROR) then
  221.     begin
  222.       DoPrintf('Could not retrieve file',[nil]);
  223.       _lclose(output_file);
  224.       Sockets2.SCancelListen;
  225.       exit;
  226.     end;
  227.     TotalRetrieveSize := GetTotalRetrieveSize;
  228.   end;
  229.   ImBusy;
  230.   Sockets2.SAccept;
  231.   ImFree;
  232.   if TimedOut or (ErrorReturn <> 0) then
  233.   begin
  234.     Application.Messagebox('Could not extablish data socket, operation canceled',
  235.       'ERROR',MB_ICONEXCLAMATION);
  236.     exit;
  237.   end;
  238.   ImBusy;
  239.   repeat
  240.     RecvData := Sockets2.Text;
  241.     if Length(RecvData) > 0 then
  242.     begin
  243.       if (IsDirList) and (not Separate) then
  244.         DoAddLine(RecvData)
  245.       else
  246.       if (IsView) and (not Separate) then
  247.         DoAddLine(RecvData)
  248.       else
  249.         begin
  250.           StrPCopy(szBuffer,RecvData);
  251.           if _lwrite(output_file,szBuffer,Length(RecvData)) = -1 then
  252.           begin
  253.             DoPrintf('%sWrite to file: %s failed, transfer incomplete',
  254.               [#13#10,LocalName]);
  255.             Aborted := True;
  256.           end;
  257.           if not IsDirList then
  258.           begin
  259.             BytesWritten := BytesWritten + Length(RecvData);
  260.             UpdateGauge(BytesWritten,TotalRetrieveSize);
  261.           end;
  262.         end;
  263.     end;
  264.     if TimedOut then
  265.     begin
  266.       Sockets1.OOB := 'ABOR'+#13#10;
  267.       ReadDisplayLine;
  268.     end;
  269.   until Length(RecvData) <= 0;
  270.   ImFree;
  271.   if Separate then
  272.   begin
  273.     _lclose(output_file);
  274.     output_file := 0;
  275.   end;
  276.   if IsDirList or IsView then
  277.     if Separate then
  278.     begin
  279.       StrPCopy(szCmd,Editor+' ');
  280.       StrCat(szCmd,szTempFileName);
  281.       WinExec(szCmd,SW_SHOW);
  282.     end;
  283.   Sockets2.SCancelListen;
  284.   Sockets2.SClose;
  285.   ReadDisplayLine;
  286.   CancelGauge;
  287. end;
  288.  
  289.  
  290. function TFTPForm.GetFTPListenPort: integer;
  291. var
  292.   i1,i2,i3,i4: integer;
  293.   IPAddr: string;
  294.   portcmd: string;
  295. begin
  296.   Sockets2.Port := '0';
  297.   Sockets2.SListen;
  298.   IPAddr := Sockets1.GetIPAddr(Sockets1.SocketNumber);
  299.   i1 := StrToInt(copy(IPAddr,1,pos('.',IPAddr)-1));
  300.   IPAddr := copy(IPAddr,pos('.',IPAddr)+1,255);
  301.   i2 := StrToInt(copy(IPAddr,1,pos('.',IPAddr)-1));
  302.   IPAddr := copy(IPAddr,pos('.',IPAddr)+1,255);
  303.   i3 := StrToInt(copy(IPAddr,1,pos('.',IPAddr)-1));
  304.   i4 := StrToInt(copy(IPAddr,pos('.',IPAddr)+1,255));
  305.   portcmd := format('PORT %d,%d,%d,%d,%d,%d',[i1,i2,i3,i4,
  306.     StrToInt(Sockets2.GetPort(Sockets2.MasterSocket)) Shr 8,
  307.     StrToInt(Sockets2.GetPort(Sockets2.MasterSocket)) and $ff]);
  308.   Result := command(portcmd,[nil]);
  309. end;
  310.  
  311. function TFTPForm.TimedOut;
  312. begin
  313.   if Aborted then
  314.   begin
  315.     Aborted := False;
  316.     Result := True;
  317.   end
  318.   else
  319.     Result := False;
  320. end;
  321.  
  322. function TFTPForm.getreply(cmdstring: string): integer;
  323. begin
  324.   Result := FTP_ERROR;
  325.   if copy(cmdstring,1,5) = 'PASS ' then
  326.     DoAddLine('PASS xxxxxx'+#13#10)
  327.   else
  328.     DoAddLine(cmdstring+#13#10);
  329.   if (Sockets1.SocketNumber = INVALID_SOCKET) or not Connected then
  330.   begin
  331.     DoAddLine('Not Connected'+#13#10);
  332.     exit;
  333.   end;
  334.   Sockets1.Text := cmdstring+#13#10;
  335.   if TimedOut or (ErrorReturn <> 0) then
  336.     exit;
  337.   Result := ReadDisplayLine;
  338. end;
  339.  
  340. function TFTPForm.command(fmt: string; const args: array of const): integer;
  341. var
  342.   Buf: string;
  343. begin
  344.   if CmdInProgress then
  345.   begin
  346.     DoPrintf('Command already in progress, request ignored',[nil]);
  347.     Result := -1;
  348.     exit;
  349.   end;
  350.   CmdInProgress := True;
  351.   ErrorReturn := 0;
  352.   ImBusy;
  353.   Buf := Format(fmt,args);
  354.   Result := getreply(Buf);
  355.   ImFree;
  356.   CmdInProgress := False;
  357. end;
  358.  
  359. function TFTPForm.DoDirList(cmd: string;const args: array of const): integer;
  360. var
  361.   Buf: string;
  362. begin
  363.   Buf := Format(cmd,args);
  364.   RetrieveFile(Buf,'','TYPE A');
  365. end;
  366.  
  367. procedure TFTPForm.DoPrintf(line: string; const args: array of const);
  368. var
  369.   str: string;
  370. begin
  371.   str := Format(line,args)+#13#10;
  372.   DoAddLine(str);
  373. end;
  374.  
  375. procedure TFTPForm.DoAddLine(Buff: string);
  376. var
  377.   idx,len,i: integer;
  378. begin
  379.   len := Length(Buff);
  380.   if len > 1 then
  381.   begin
  382.     for i := 1 to len do
  383.     begin
  384.       if Buff[i] = #10 then
  385.       begin
  386.         try
  387.         Memo1.Lines.Add(line);
  388.         except
  389.           on EOutOfResources do
  390.             begin
  391.               Memo1.Clear;
  392.               Memo1.Lines.Add('Cleared output area due to limited  resources');
  393.             end;
  394.         end;
  395.         line := '';
  396.       end
  397.       else
  398.         if Buff[i] <> #0 then
  399.           line := line + Buff[i];
  400.     end
  401.   end;
  402. end;
  403.  
  404.  
  405. function TFTPForm.ReadDisplayLine: integer;
  406. var
  407.   Buff: string;
  408.   szBuff: array[0..255] of char absolute Buff;
  409.   ch: char;
  410.   idx,len: integer;
  411. begin
  412.   Result := FTP_ERROR;
  413.   repeat
  414.     ch := #0;
  415.     Buff := Sockets1.Peek;
  416.     if TimedOut or (ErrorReturn <> 0) then
  417.       exit;
  418.     idx := pos(#10,Buff);
  419.     if idx > 0 then
  420.     begin
  421.       len := idx;
  422.       Sockets1.SReceive(Sockets1.SocketNumber,@szBuff[1],len);
  423.       if TimedOut or (ErrorReturn <> 0) then
  424.         exit;
  425.       szBuff[0] := chr(len);
  426.       GlobalBuff := Buff; {Kludge d'jour}
  427.       DoAddLine(Buff);
  428.       if Buff[4] <> '-' then { continuation ? }
  429.         ch := Buff[1];
  430.     end;
  431.   until (ch >= '1') and (ch <= '5');
  432.   Result := ord(ch) - $30;
  433. end;
  434.  
  435. procedure TFTPForm.ConnectMNUClick(Sender: TObject);
  436. var
  437.   iLength: integer;
  438.   iRetCode: integer;
  439.   iFlag: integer;
  440.   ftp_host: string;
  441. begin
  442.   if Connected then
  443.   begin
  444.     DoPrintf('Already connected to remote host: %s',[Sockets1.IPAddr]);
  445.     exit;
  446.   end;
  447.   line := '';
  448.   ErrorReturn := 0;
  449.   Memo1.Clear;
  450.   LoginDLG.ShowModal;
  451.   if LoginDLG.ModalResult = mrCancel then
  452.     exit;
  453.   ftp_host := LoginDLG.HostName.Text;
  454.   Sockets1.Port := '21';
  455.   Sockets1.IPAddr := ftp_host;
  456.   Sockets1.NonBlocking := False;
  457.   ImBusy;
  458.   Sockets1.SConnect;
  459.   ImFree;
  460.   if Aborted or (ErrorReturn <> 0) or (Sockets1.SocketNumber = INVALID_SOCKET) then
  461.   begin
  462.     DoPrintf('Connection to %s failed',[ftp_host]);
  463.     exit;
  464.   end;
  465.   Connected := True;
  466.   doprintf('Local port: %s IP: %s connected to rmt port: %s IP: %s',
  467.     [Sockets1.GetPort(Sockets1.SocketNumber),
  468.      Sockets1.GetIPAddr(Sockets1.SocketNumber),
  469.      Sockets1.GetPeerPort(Sockets1.SocketNumber),
  470.      Sockets1.GetPeerIPAddr(Sockets1.SocketNumber)]);
  471.   DoPrintf('Connected to %s',[Sockets1.IPAddr]);
  472.   repeat
  473.     iRetCode := ReadDisplayLine;
  474.   until (iRetCode <> FTP_PRELIM) or (Aborted = True);
  475.   if command('USER %s',[LoginDLG.UserName.Text]) = FTP_CONTINUE then
  476.     if LoginDLG.Password.Text <> '' then
  477.       if command('PASS %s',[LoginDlg.PassWord.Text]) = FTP_CONTINUE then
  478.         if LoginDLG.Account.Text <> '' then
  479.           command('ACCT %s',[LoginDLG.Account.Text]);
  480.   if LoginDLG.Directory.Text <> '' then
  481.     command('CWD %s',[LoginDLG.Directory.Text]);
  482.   EnableDisableMenus;
  483. end;
  484.  
  485. procedure TFTPForm.DirMNUClick(Sender: TObject);
  486. var
  487.   args: string;
  488. begin
  489.   args := '*.*';
  490.   if InputQuery('Remote Directory Listing','Pattern:',args) then
  491.     if args = '*.*' then
  492.       DoDirlist('LIST',[nil])
  493.     else
  494.       DoDirList('LIST %s',[args]);
  495. end;
  496.  
  497. procedure TFTPForm.QuitMNUClick(Sender: TObject);
  498. begin
  499.   command('QUIT',[nil]);
  500.   Sockets1.SClose;
  501.   Connected := False;
  502.   EnableDisableMenus;
  503. end;
  504.  
  505. procedure TFTPForm.GetMNUClick(Sender: TObject);
  506. var
  507.   rtype: string;
  508. begin
  509.   GetDLG.ShowModal;
  510.   if GetDLG.ModalResult = mrCancel then
  511.     exit;
  512.   if GetDLG.rbASCII.Checked = True then
  513.     rtype := 'TYPE A'
  514.   else if GetDLG.rbBINARY.Checked = True then
  515.     rtype := 'TYPE I'
  516.     else
  517.       rtype := 'TYPE E';
  518.   RetrieveFile(GetDLG.FileName.Text,GetDlg.LocalName.Text,rtype);
  519. end;
  520.  
  521. procedure TFTPForm.PutMNUClick(Sender: TObject);
  522. var
  523.   PCFile, RMTFile: string;
  524.   szPCFile: array[0..255] of char;
  525.   NumBytes: integer;
  526.   BytesWritten: longint;
  527.   Buff: string;
  528.   szBuff: array[0..255] of char absolute Buff;
  529.   trans_type: string;
  530.   input_file: integer;
  531.   TotalSendSize: longint;
  532. begin
  533.   PutDLG.ShowModal;
  534.   if PutDLG.ModalResult = mrCancel then
  535.     exit;
  536.   if PutDLG.rbASCII.Checked = True then
  537.     trans_type := 'TYPE A'
  538.   else if PutDLG.rbBINARY.Checked = True then
  539.     trans_type := 'TYPE I'
  540.     else
  541.       trans_type := 'TYPE E';
  542.   StrPCopy(szPCFile,PutDLG.FileName.Text);
  543.   input_file := _lopen(szPCFile,0);
  544.   if input_file = -1 then
  545.   begin
  546.     Application.MessageBox('Could not open local file','open error',MB_ICONEXCLAMATION);
  547.     exit;
  548.   end;
  549.   TotalSendSize := _llseek(input_file,0,2);
  550.   _llseek(input_file,0,0);
  551.   DoPrintf('Transferring local file: %s to remote file: %s',
  552.     [PutDLG.FileName.Text,PutDLG.RemoteName.Text]);
  553.   command(trans_type,[nil]);
  554.   Sockets2.NonBlocking := False;
  555.   Sockets2.Timeout := 30;
  556.   GetFTPListenPort;
  557.   command('STOR %s',[PutDLG.RemoteName.Text]);
  558.   Sockets2.SAccept;
  559.   BytesWritten := 0;
  560.   ImBusy;
  561.   NumBytes := _lread(input_file,@szBuff[1],255);
  562.   while NumBytes > 0 do
  563.   begin
  564.     szBuff[0] := chr(NumBytes);
  565.     Sockets2.Text := Buff;
  566.     BytesWritten := BytesWritten + NumBytes;
  567.     UpdateGauge(BytesWritten,TotalSendSize);
  568.     NumBytes := _lread(input_file,@szBuff[1],255);
  569.     if TimedOut then
  570.     begin
  571.       Sockets1.OOB := 'ABOR'+#13#10;
  572.       ReadDisplayLine;
  573.       Sockets2.SCancelListen;
  574.       Sockets2.SClose;
  575.       _lclose(input_file);
  576.       ImFree;
  577.       DoPrintf('%sTransfer aborted due to you''re request',[#13#10]);
  578.       exit;
  579.     end;
  580.   end;
  581.   if NumBytes = -1 then
  582.     DoPrintf('File Error, File transfer may be incomplete',[nil]);
  583.   Sockets2.SCancelListen;
  584.   Sockets2.SClose;
  585.   _lclose(input_file);
  586.   ImFree;
  587.   DoPrintf('Total bytes written to remote host: %s',[IntToStr(BytesWritten)]);
  588.   ReadDisplayLine;
  589.   CancelGauge;
  590. end;
  591.  
  592. procedure TFTPForm.ExitMNUClick(Sender: TObject);
  593. begin
  594.   if Connected then
  595.   begin
  596.     DoPrintf('Disconnecting from remote host: %s',[Sockets1.IPAddr]);
  597.     QuitMNUClick(self);
  598.   end;
  599.   Close;
  600. end;
  601.  
  602. procedure TFTPForm.ChDirMNUClick(Sender: TObject);
  603. var
  604.   args: string;
  605. begin
  606.   args := '';
  607.   if InputQuery('Change Directory','Directory:',args) then
  608.     command('CWD %s',[args]);
  609. end;
  610.  
  611. procedure TFTPForm.ParentMNUClick(Sender: TObject);
  612. begin
  613.   command('CDUP',[nil]);
  614. end;
  615.  
  616. procedure TFTPForm.MkDirMNUClick(Sender: TObject);
  617. var
  618.   args: string;
  619. begin
  620.   args := '';
  621.   if InputQuery('Make Directory','Directory:',args) then
  622.     command('MKD %s',[args]);
  623. end;
  624.  
  625. procedure TFTPForm.RmDirMNUClick(Sender: TObject);
  626. var
  627.   args: string;
  628. begin
  629.   args := '';
  630.   if InputQuery('Remove Directory','Directory:',args) then
  631.     command('RMD %s',[args]);
  632. end;
  633.  
  634. procedure TFTPForm.PwdMNUClick(Sender: TObject);
  635. begin
  636.   command('PWD',[nil]);
  637. end;
  638.  
  639. procedure TFTPForm.RenameMNUClick(Sender: TObject);
  640. begin
  641.   RenDLG.ShowModal;
  642.   if RenDLG.ModalResult = mrCancel then
  643.     exit;
  644.   if command('RNFR %s',[RenDLG.FileFrom.Text]) = FTP_CONTINUE then
  645.     command('RNTO %s',[RenDLG.FileTo.Text]);
  646. end;
  647.  
  648.  
  649. procedure TFTPForm.DeleteMNUClick(Sender: TObject);
  650. var
  651.   args: string;
  652. begin
  653.   args := '';
  654.   if InputQuery('Delete Remote File','File to Delete:',args) then
  655.     command('DELE %s',[args]);
  656. end;
  657.  
  658. procedure TFTPForm.HelpMNUClick(Sender: TObject);
  659. begin
  660.   command('HELP',[nil]);
  661. end;
  662.  
  663. procedure TFTPForm.QuoteMNUClick(Sender: TObject);
  664. var
  665.   args: string;
  666. begin
  667.   args := '';
  668.   if InputQuery('Enter FTP command','Command:',args) then
  669.     command('%s',[args]);
  670. end;
  671.  
  672. procedure TFTPForm.EnableDisableMenus;
  673. var
  674.   ed: Boolean;
  675. begin
  676.   ed := False;
  677.   if Connected then
  678.     ed := True;
  679.   ChDirMNU.Enabled := ed;
  680.   ConnectMNU.Enabled := not ed;
  681.   DeleteMNU.Enabled := ed;
  682.   DirMNU.Enabled := ed;
  683.   GetMNU.Enabled := ed;
  684.   HelpMNU.Enabled := ed;
  685.   MkDirMNU.Enabled := ed;
  686.   PutMNU.Enabled := ed;
  687.   QuitMNU.Enabled := ed;
  688.   QuoteMNU.Enabled := ed;
  689.   RenameMNU.Enabled := ed;
  690.   RMDirMNU.Enabled := ed;
  691.   PwdMNU.Enabled := ed;
  692.   ViewMNU.Enabled := ed;
  693.   CancelMNU.Enabled := ed;
  694.   ParentMNU.Enabled := ed;
  695. end;
  696.  
  697. procedure TFTPForm.FormCreate(Sender: TObject);
  698. var
  699.   ftpini: TIniFile;
  700. begin
  701.   Connected := False;
  702.   EnableDisableMenus;
  703.   ftpini := TIniFile.Create('FTPPROF.INI');
  704.   DirSep := ftpini.ReadString('options','DirSep','');
  705.   ViewSep := ftpini.ReadString('options','ViewSep','');
  706.   Editor := ftpini.ReadString('options','Editor','');
  707.   if (DirSep = '') and (ViewSep = '') and (Editor = '') then
  708.   begin
  709.     DirSep := '0';
  710.     ftpini.WriteString('options','DirSep',DirSep);
  711.     ViewSep := '1';
  712.     ftpini.WriteString('options','ViewSep',ViewSep);
  713.     Editor := 'NOTEPAD.EXE';
  714.     ftpini.WriteString('options','Editor',Editor);
  715.   end;
  716.   if DirSep = '0' then
  717.     DirSepMNU.Checked := False
  718.   else
  719.     DirSepMnu.Checked := True;
  720.   if ViewSep = '0' then
  721.     ViewSepMNU.Checked := False
  722.   else
  723.     ViewSepMnu.Checked := True;
  724. end;
  725.  
  726. procedure TFTPForm.ViewMNUClick(Sender: TObject);
  727. var
  728.  rtype: string;
  729. begin
  730.   ViewDLG.ShowModal;
  731.   if ViewDLG.ModalResult = mrCancel then
  732.     exit;
  733.   if ViewDLG.rbASCII.Checked = True then
  734.     rtype :=  'TYPE A'
  735.   else if ViewDLG.rbBINARY.Checked = True then
  736.     rtype := 'TYPE I'
  737.     else
  738.       rtype := 'TYPE E';
  739.   RetrieveFile(ViewDLG.FileName.Text,'',rtype);
  740. end;
  741.  
  742. procedure TFTPForm.CancelMNUClick(Sender: TObject);
  743. begin
  744.   Aborted := True;
  745. end;
  746.  
  747. procedure TFTPForm.ImBusy;
  748. begin
  749.   FTPForm.Cursor := crHourGlass;
  750.   Memo1.Cursor := crHourGlass;
  751. end;
  752.  
  753. procedure TFTPForm.ImFree;
  754. begin
  755.   FTPForm.Cursor := crDefault;
  756.   Memo1.Cursor := crDefault;
  757. end;
  758.  
  759.  
  760. procedure TFTPForm.EditorMNUClick(Sender: TObject);
  761. var
  762.   ftpini: TIniFile;
  763. begin
  764.   ftpini := TIniFile.Create('FTPPROF.INI');
  765.   Editor := ftpini.ReadString('options','Editor','');
  766.   Editor := InputBox('Enter preferred editor','Editor:',Editor);
  767.   ftpini.WriteString('options','Editor',Editor);
  768. end;
  769.  
  770. procedure TFTPForm.DirSepMNUClick(Sender: TObject);
  771. var
  772.   ftpini: TIniFile;
  773. begin
  774.   ftpini := TIniFile.Create('FTPPROF.INI');
  775.   if DirSep = '0' then
  776.   begin
  777.     DirSep := '1';
  778.     DirSepMNU.Checked := True;
  779.   end
  780.   else
  781.   begin
  782.     DirSep := '0';
  783.     DirSepMNU.Checked := False;
  784.   end;
  785.   ftpini.WriteString('options','DirSep',DirSep);
  786. end;
  787.  
  788. procedure TFTPForm.ViewSepMNUClick(Sender: TObject);
  789. var
  790.   ftpini: TIniFile;
  791. begin
  792.   ftpini := TIniFile.Create('FTPPROF.INI');
  793.   if ViewSep = '0' then
  794.   begin
  795.     ViewSep := '1';
  796.     ViewSepMNU.Checked := True;
  797.   end
  798.   else
  799.   begin
  800.     ViewSep := '0';
  801.     ViewSepMNU.Checked := False;
  802.   end;
  803.   ftpini.WriteString('options','ViewSep',ViewSep);
  804. end;
  805.  
  806. function TFTPForm.GetTotalRetrieveSize: longint;
  807. var
  808.   left,right: integer;
  809.   tmp: string;
  810. begin
  811.   left := pos('(',GlobalBuff);
  812.   if (left = 0) or (right = 0) then
  813.   begin
  814.     Result := 0;
  815.     exit;
  816.   end;
  817.   tmp := copy(GlobalBuff,left+1,right-left-1);
  818.   right := pos(' ',tmp);
  819.   if right <> 0 then
  820.     tmp := copy(tmp,1,right-1);
  821.   try
  822.     Result := StrToInt(tmp);
  823.   except
  824.     on EConvertError do Result := 0;
  825.   end;
  826. end;
  827.  
  828. procedure TFTPForm.UpdateGauge(BytesWritten, TotalTransferSize: longint);
  829. var
  830.   per, oldval: longint;
  831. begin
  832.   if TotalTransferSize = 0 then
  833.     exit;
  834.   if MeterDLG.Visible = False then
  835.     MeterDLG.Show;
  836.   oldval := MeterDLG.Gauge1.Value;
  837.   per := trunc(100.0 / (TotalTransferSize / BytesWritten));
  838.   MeterDLG.Gauge1.Value := per;
  839.   MeterDLG.Label1.Caption := IntToStr(per)+'% Complete';
  840.   if per <> oldval then
  841.     MeterDLG.Refresh;
  842. end;
  843.  
  844. procedure TFTPForm.CancelGauge;
  845. begin
  846.   MeterDLG.Hide;
  847. end;
  848.  
  849.  
  850. end.
  851.